home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / cmdloop.el.z / cmdloop.el
Encoding:
Text File  |  1998-05-21  |  20.7 KB  |  539 lines
  1. ;;; cmdloop.el --- support functions for the top-level command loop.
  2.  
  3. ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  19. ;; Free Software Foundation, 59 Temple Place - Suite 330,
  20. ;; Boston, MA 02111-1307, USA.
  21.  
  22. ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.)
  23.  
  24. ;; Written by Richard Mlynarik 8-Jul-92
  25.  
  26. (defun recursion-depth ()
  27.   "Return the current depth in recursive edits."
  28.   (+ command-loop-level (minibuffer-depth)))
  29.  
  30. (defun top-level ()
  31.   "Exit all recursive editing levels."
  32.   (interactive)
  33.   (throw 'top-level nil))
  34.  
  35. (defun exit-recursive-edit ()
  36.   "Exit from the innermost recursive edit or minibuffer."
  37.   (interactive)
  38.   (if (> (recursion-depth) 0)
  39.       (throw 'exit nil))
  40.   (error "No recursive edit is in progress"))
  41.  
  42. (defun abort-recursive-edit ()
  43.   "Abort the command that requested this recursive edit or minibuffer input."
  44.   (interactive)
  45.   (if (> (recursion-depth) 0)
  46.       (throw 'exit t))
  47.   (error "No recursive edit is in progress"))
  48.  
  49. ;; (defun keyboard-quit ()
  50. ;;   "Signal a `quit' condition."
  51. ;;   (interactive)
  52. ;;  (deactivate-mark)
  53. ;;   (signal 'quit nil))
  54.  
  55. ;; moved here from pending-del.
  56. (defun keyboard-quit ()
  57.   "Signal a `quit' condition.
  58. If this character is typed while lisp code is executing, it will be treated
  59.  as an interrupt.
  60. If this character is typed at top-level, this simply beeps.
  61. If `zmacs-regions' is true, and the zmacs region is active in this buffer,
  62. then this key deactivates the region without beeping or signalling."
  63.   (interactive)
  64.   (if (and (region-active-p)
  65.        (eq (current-buffer) (zmacs-region-buffer)))
  66.       ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
  67.       ;; deactivating the region.  If it is inactive, beep.
  68.       nil
  69.     (signal 'quit nil)))
  70.  
  71. (defvar buffer-quit-function nil
  72.   "Function to call to \"quit\" the current buffer, or nil if none.
  73. \\[keyboard-escape-quit] calls this function when its more local actions
  74. \(such as cancelling a prefix argument, minibuffer or region) do not apply.")
  75.  
  76. (defun keyboard-escape-quit ()
  77.   "Exit the current \"mode\" (in a generalized sense of the word).
  78. This command can exit an interactive command such as `query-replace',
  79. can clear out a prefix argument or a region,
  80. can get out of the minibuffer or other recursive edit,
  81. cancel the use of the current buffer (for special-purpose buffers),
  82. or go back to just one window (by deleting all but the selected window)."
  83.   (interactive)
  84.   (cond ((eq last-command 'mode-exited) nil)
  85.     ((> (minibuffer-depth) 0)
  86.      (abort-recursive-edit))
  87.     (current-prefix-arg
  88.      nil)
  89.     ((region-active-p)
  90.      (zmacs-deactivate-region))
  91.     ((> (recursion-depth) 0)
  92.      (exit-recursive-edit))
  93.     (buffer-quit-function
  94.      (funcall buffer-quit-function))
  95.     ((not (one-window-p t))
  96.      (delete-other-windows))
  97.     ((string-match "^ \\*" (buffer-name (current-buffer)))
  98.      (bury-buffer))))
  99.  
  100. ;;#### This should really be a ring of last errors.
  101. (defvar last-error nil
  102.   "#### Document me.")
  103.  
  104. (defcustom errors-deactivate-region nil
  105.   "*Non-nil means that errors will cause the region to be deactivated."
  106.   :type 'boolean
  107.   :group 'editing-basics)
  108.  
  109. (defun command-error (error-object)
  110.   (let ((inhibit-quit t)
  111.     (debug-on-error nil)
  112.     (etype (car-safe error-object)))
  113.     (setq quit-flag nil)
  114.     (setq standard-output t)
  115.     (setq standard-input t)
  116.     (setq executing-kbd-macro nil)
  117.     (and errors-deactivate-region
  118.      (zmacs-deactivate-region))
  119.     (discard-input)
  120.  
  121.     (setq last-error error-object)
  122.  
  123.     (message nil)
  124.     (ding nil (cond ((eq etype 'undefined-keystroke-sequence)
  125.              (if (and (vectorp (nth 1 error-object))
  126.                   (/= 0 (length (nth 1 error-object)))
  127.                   (button-event-p (aref (nth 1 error-object) 0)))
  128.              'undefined-click
  129.                'undefined-key))
  130.             ((eq etype 'quit)
  131.              'quit)
  132.             ((memq etype '(end-of-buffer beginning-of-buffer))
  133.              'buffer-bound)
  134.             ((eq etype 'buffer-read-only)
  135.              'read-only)
  136.             (t 'command-error)))
  137.     (display-error error-object t)
  138.  
  139.     (if (noninteractive)
  140.         (progn
  141.           (message "XEmacs exiting.")
  142.           (kill-emacs -1)))
  143.     t))
  144.  
  145. (defun describe-last-error ()
  146.   "Redisplay the last error-message.  See the variable `last-error'."
  147.   (interactive)
  148.   (with-displaying-help-buffer
  149.    (lambda ()
  150.      (princ "Last error was:\n" standard-output)
  151.      (display-error last-error standard-output))))
  152.  
  153.  
  154. ;;#### Must be done later in the loadup sequence
  155. ;(define-key (symbol-function 'help-command) "e" 'describe-last-error)
  156.  
  157.  
  158. (defun truncate-command-history-for-gc ()
  159.   (let ((tail (nthcdr 30 command-history)))
  160.     (if tail (setcdr tail nil)))
  161.   (let ((tail (nthcdr 30 values)))
  162.     (if tail (setcdr tail nil)))
  163.   )
  164.  
  165. (add-hook 'pre-gc-hook 'truncate-command-history-for-gc)
  166.  
  167.  
  168. ;;;; Object-oriented programming at its finest
  169.  
  170. ;; Now in src/print.c; used by Ferror_message_string and others
  171. ;(defun display-error (error-object stream) ;(defgeneric report-condition ...)
  172. ;  "Display `error-object' on `stream' in a user-friendly way."
  173. ;  (funcall (or (let ((type (car-safe error-object)))
  174. ;                 (catch 'error
  175. ;                   (and (consp error-object)
  176. ;                        (symbolp type)
  177. ;                        ;;(stringp (get type 'error-message))
  178. ;            (consp (get type 'error-conditions))
  179. ;                        (let ((tail (cdr error-object)))
  180. ;                          (while (not (null tail))
  181. ;                            (if (consp tail)
  182. ;                                (setq tail (cdr tail))
  183. ;                                (throw 'error nil)))
  184. ;                          t)
  185. ;                        ;; (check-type condition condition)
  186. ;                        (get type 'error-conditions)
  187. ;                        ;; Search class hierarchy
  188. ;                        (let ((tail (get type 'error-conditions)))
  189. ;                          (while (not (null tail))
  190. ;                            (cond ((not (and (consp tail)
  191. ;                                             (symbolp (car tail))))
  192. ;                                   (throw 'error nil))
  193. ;                                  ((get (car tail) 'display-error)
  194. ;                                   (throw 'error (get (car tail)
  195. ;                                                      'display-error)))
  196. ;                                  (t
  197. ;                                   (setq tail (cdr tail)))))
  198. ;                          ;; Default method
  199. ;                          #'(lambda (error-object stream)
  200. ;                              (let ((type (car error-object))
  201. ;                                    (tail (cdr error-object))
  202. ;                                    (first t)
  203. ;                    (print-message-label 'error))
  204. ;                                (if (eq type 'error)
  205. ;                                    (progn (princ (car tail) stream)
  206. ;                                           (setq tail (cdr tail)))
  207. ;                  (princ (or (gettext (get type 'error-message)) type)
  208. ;                     stream))
  209. ;                                (while tail
  210. ;                                  (princ (if first ": " ", ") stream)
  211. ;                                  (prin1 (car tail) stream)
  212. ;                                  (setq tail (cdr tail)
  213. ;                                        first nil))))))))
  214. ;           #'(lambda (error-object stream)
  215. ;                   (princ (gettext "Peculiar error ") stream)
  216. ;                   (prin1 error-object stream)))
  217. ;           error-object stream))
  218.  
  219. (put 'file-error 'display-error
  220.      #'(lambda (error-object stream)
  221.          (let ((tail (cdr error-object))
  222.                (first t))
  223.            (princ (car tail) stream)
  224.            (while (setq tail (cdr tail))
  225.              (princ (if first ": " ", ") stream)
  226.              (princ (car tail) stream)
  227.              (setq first nil)))))
  228.  
  229. (put 'undefined-keystroke-sequence 'display-error
  230.      #'(lambda (error-object stream)
  231.          (princ (key-description (car (cdr error-object))) stream)
  232.      ;; #### I18N3: doesn't localize properly.
  233.          (princ (gettext " not defined.") stream) ; doo dah, doo dah.
  234.          ))
  235.  
  236.  
  237. (defcustom teach-extended-commands-p t
  238.   "*If true, then `\\[execute-extended-command]' will teach you keybindings.
  239. Any time you execute a command with \\[execute-extended-command] which has a
  240. shorter keybinding, you will be shown the alternate binding before the
  241. command executes.  There is a short pause after displaying the binding,
  242. before executing it; the length can be controlled by
  243. `teach-extended-commands-timeout'."
  244.   :type 'boolean
  245.   :group 'keyboard)
  246.  
  247. (defcustom teach-extended-commands-timeout 4
  248.   "*How long to pause after displaying a keybinding before executing.
  249. The value is measured in seconds.  This only applies if
  250. `teach-extended-commands-p' is true."
  251.   :type 'number
  252.   :group 'keyboard)
  253.  
  254. ;;; This is implemented differently in GNU Emacs.
  255. ;;; We can't support both properly until we have Lisp magic variables.
  256. ;(defvar suggest-key-bindings t
  257. ;  "*FSFmacs equivalent of `teach-extended-commands-*'.
  258. ;Provided for compatibility only.
  259. ;Non-nil means show the equivalent key-binding when M-x command has one.
  260. ;The value can be a length of time to show the message for.
  261. ;If the value is non-nil and not a number, we wait 2 seconds.")
  262. ;
  263. ;(make-obsolete-variable 'suggest-key-bindings 'teach-extended-commands-p)
  264.  
  265. (defun execute-extended-command (prefix-arg)
  266.   "Read a command name from the minibuffer using 'completing-read'.
  267. Then call the specified command using 'command-execute' and return its
  268. return value.  If the command asks for a prefix argument, supply the
  269. value of the current raw prefix argument, or the value of PREFIX-ARG
  270. when called from Lisp."
  271.   (interactive "P")
  272.   ;; Note:  This doesn't hack "this-command-keys"
  273.   (let ((prefix-arg prefix-arg))
  274.     (setq this-command (read-command
  275.                         ;; Note: this has the hard-wired
  276.                         ;;  "C-u" and "M-x" string bug in common
  277.                         ;;  with all GNU Emacs's.
  278.             ;; (i.e. it prints C-u and M-x regardless of
  279.             ;; whether some other keys were actually bound
  280.             ;; to `execute-extended-command' and 
  281.             ;; `universal-argument'.
  282.                         (cond ((eq prefix-arg '-)
  283.                                "- M-x ")
  284.                               ((equal prefix-arg '(4))
  285.                                "C-u M-x ")
  286.                               ((integerp prefix-arg)
  287.                                (format "%d M-x " prefix-arg))
  288.                               ((and (consp prefix-arg)
  289.                                     (integerp (car prefix-arg)))
  290.                                (format "%d M-x " (car prefix-arg)))
  291.                               (t
  292.                                "M-x ")))))
  293.  
  294.   (if (and teach-extended-commands-p
  295.        (interactive-p))
  296.       ;; We need to fiddle with keys: remember the keys, run the
  297.       ;; command, and show the keys (if any).
  298.       (let ((_execute_command_keys_ (where-is-internal this-command))
  299.         (_execute_command_name_ this-command)) ; the name can change
  300.     (command-execute this-command t)
  301.     (when (and _execute_command_keys_
  302.            ;; Wait for a while, so the user can see a message
  303.            ;; printed, if any.
  304.            (sit-for 1))
  305.       (display-message
  306.        'no-log
  307.        (format "Command `%s' is bound to key%s: %s"
  308.            _execute_command_name_
  309.            (if (cdr _execute_command_keys_) "s" "")
  310.            (sorted-key-descriptions _execute_command_keys_)))
  311.       (sit-for teach-extended-commands-timeout)
  312.       (clear-message 'no-log)))
  313.     ;; Else, just run the command.
  314.     (command-execute this-command t)))
  315.  
  316.  
  317. ;;; C code calls this; the underscores in the variable names are to avoid
  318. ;;; cluttering the specbind namespace (lexical scope!  lexical scope!)
  319. ;;; Putting this in Lisp instead of C slows kbd macros by 50%.
  320. ;(defun command-execute (_command &optional _record-flag)
  321. ;  "Execute CMD as an editor command.
  322. ;CMD must be a symbol that satisfies the `commandp' predicate.
  323. ;Optional second arg RECORD-FLAG non-nil
  324. ;means unconditionally put this command in `command-history'.
  325. ;Otherwise, that is done only if an arg is read using the minibuffer."
  326. ;  (let ((_prefix prefix-arg)
  327. ;        (_cmd (indirect-function _command)))
  328. ;    (setq prefix-arg nil
  329. ;          this-command _command
  330. ;          current-prefix-arg _prefix
  331. ;          zmacs-region-stays nil)
  332. ;    ;; #### debug_on_next_call = 0;
  333. ;    (cond ((and (symbolp _command)
  334. ;                (get _command 'disabled))
  335. ;           (run-hooks disabled-command-hook))
  336. ;          ((or (stringp _cmd) (vectorp _cmd))
  337. ;           ;; If requested, place the macro in the command history.  
  338. ;           ;;  For other sorts of commands, call-interactively takes
  339. ;           ;;  care of this. 
  340. ;           (if _record-flag
  341. ;               (setq command-history
  342. ;                     (cons (list 'execute-kbd-macro _cmd _prefix)
  343. ;                           command-history)))
  344. ;             (execute-kbd-macro _cmd _prefix))
  345. ;            (t
  346. ;             (call-interactively _command _record-flag)))))
  347.  
  348. (defun y-or-n-p-minibuf (prompt)
  349.   "Ask user a \"y or n\" question.  Return t if answer is \"y\".
  350. Takes one argument, which is the string to display to ask the question.
  351. It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
  352. No confirmation of the answer is requested; a single character is enough.
  353. Also accepts Space to mean yes, or Delete to mean no."
  354.   (save-excursion
  355.     (let* ((pre "")
  356.            (yn (gettext "(y or n) "))
  357.        ;; we need to translate the prompt ourselves because of the
  358.        ;; strange way we handle it.
  359.        (prompt (gettext prompt))
  360.            event)
  361.       (while (stringp yn)
  362.         (if (let ((cursor-in-echo-area t)
  363.                   (inhibit-quit t))
  364.               (message "%s%s%s" pre prompt yn)
  365.               (setq event (next-command-event event))
  366.           (condition-case nil
  367.           (prog1
  368.               (or quit-flag (eq 'keyboard-quit (key-binding event)))
  369.             (setq quit-flag nil))
  370.         (wrong-type-argument t)))
  371.             (progn
  372.               (message "%s%s%s%s" pre prompt yn (single-key-description event))
  373.               (setq quit-flag nil)
  374.               (signal 'quit '())))
  375.         (let* ((keys (events-to-keys (vector event)))
  376.            (def (lookup-key query-replace-map keys)))
  377.           (cond ((eq def 'skip)
  378.                  (message "%s%sNo" prompt yn)
  379.          (setq yn nil))
  380.                 ((eq def 'act)
  381.                  (message "%s%sYes" prompt yn)
  382.          (setq yn t))
  383.         ((eq def 'recenter)
  384.          (recenter))
  385.         ((or (eq def 'quit) (eq def 'exit-prefix))
  386.          (signal 'quit '()))
  387.                 ((button-release-event-p event) ; ignore them
  388.                  nil)
  389.                 (t
  390.                  (message "%s%s%s%s" pre prompt yn
  391.                           (single-key-description event))
  392.                  (ding nil 'y-or-n-p)
  393.                  (discard-input)
  394.                  (if (= (length pre) 0)
  395.                      (setq pre (gettext "Please answer y or n.  ")))))))
  396.       yn)))
  397.  
  398. (defun yes-or-no-p-minibuf (prompt)
  399.   "Ask user a yes-or-no question.  Return t if answer is yes.
  400. Takes one argument, which is the string to display to ask the question.
  401. It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
  402. The user must confirm the answer with RET,
  403. and can edit it until it has been confirmed."
  404.   (save-excursion
  405.     (let ((p (concat (gettext prompt) (gettext "(yes or no) ")))
  406.           (ans ""))
  407.       (while (stringp ans)
  408.         (setq ans (downcase (read-string p nil t))) ;no history
  409.         (cond ((string-equal ans (gettext "yes"))
  410.                (setq ans 't))
  411.               ((string-equal ans (gettext "no"))
  412.                (setq ans 'nil))
  413.               (t
  414.                (ding nil 'yes-or-no-p)
  415.                (discard-input)
  416.                (message "Please answer yes or no.")
  417.                (sleep-for 2))))
  418.       ans)))
  419.  
  420. ;; these may be redefined later, but make the original def easily encapsulable
  421. (define-function 'yes-or-no-p 'yes-or-no-p-minibuf)
  422. (define-function 'y-or-n-p 'y-or-n-p-minibuf)
  423.  
  424.  
  425. (defun read-char ()
  426.   "Read a character from the command input (keyboard or macro).
  427. If a mouse click or non-ASCII character is detected, an error is
  428. signalled.  The character typed is returned as an ASCII value.  This
  429. is most likely the wrong thing for you to be using: consider using
  430. the `next-command-event' function instead."
  431.   (save-excursion
  432.     (let* ((inhibit-quit t)
  433.        (event (next-command-event)))
  434.       (prog1 (or (event-to-character event)
  435.                  ;; Kludge.  If the event we read was a mouse-release,
  436.                  ;; discard it and read the next one.
  437.                  (if (button-release-event-p event)
  438.                      (event-to-character (next-command-event event)))
  439.                  (error "Key read has no ASCII equivalent %S" event))
  440.         ;; this is not necessary, but is marginally more efficient than GC.
  441.         (deallocate-event event)))))
  442.  
  443. (defun read-char-exclusive ()
  444.   "Read a character from the command input (keyboard or macro).
  445. If a mouse click or non-ASCII character is detected, it is discarded.
  446. The character typed is returned as an ASCII value.  This is most likely
  447. the wrong thing for you to be using: consider using the
  448. `next-command-event' function instead."
  449.   (let ((inhibit-quit t)
  450.     event ch)
  451.     (while (progn
  452.          (setq event (next-command-event))
  453.          (setq ch (event-to-character event))
  454.          (deallocate-event event)
  455.          (null ch)))
  456.     ch))
  457.  
  458. (defun read-quoted-char (&optional prompt)
  459.   "Like `read-char', except that if the first character read is an octal
  460. digit, we read up to two more octal digits and return the character
  461. represented by the octal number consisting of those digits.
  462. Optional argument PROMPT specifies a string to use to prompt the user."
  463.   (save-excursion
  464.     (let ((count 0) (code 0)
  465.       (prompt (and prompt (gettext prompt)))
  466.       char event)
  467.       (while (< count 3)
  468.         (let ((inhibit-quit (zerop count))
  469.         ;; Don't let C-h get the help message--only help function keys.
  470.         (help-char nil)
  471.         (help-form
  472.          "Type the special character you want to use,
  473. or three octal digits representing its character code."))
  474.           (and prompt (display-message 'prompt (format "%s-" prompt)))
  475.           (setq event (next-command-event)
  476.                 char (or (event-to-character event nil nil t)
  477.                          (error "key read cannot be inserted in a buffer: %S"
  478.                           event)))
  479.           (if inhibit-quit (setq quit-flag nil)))
  480.         (cond ((null char))
  481.               ((and (<= ?0 char) (<= char ?7))
  482.                (setq code (+ (* code 8) (- char ?0))
  483.                      count (1+ count))
  484.                (and prompt (display-message
  485.                 'prompt
  486.                 (setq prompt (format "%s %c" prompt char)))))
  487.               ((> count 0)
  488.                (setq unread-command-event event
  489.                      count 259))
  490.               (t (setq code char count 259))))
  491.     ;; Turn a meta-character into a character with the 0200 bit set.
  492.     (logior (if (/= (logand code ?\M-\^@) 0) 128 0)
  493.         (logand 255 code)))))
  494.  
  495. (defun momentary-string-display (string pos &optional exit-char message) 
  496.   "Momentarily display STRING in the buffer at POS.
  497. Display remains until next character is typed.
  498. If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
  499. otherwise it is then available as input (as a command if nothing else).
  500. Display MESSAGE (optional fourth arg) in the echo area.
  501. If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
  502.   (or exit-char (setq exit-char ?\ ))
  503.   (let ((buffer-read-only nil)
  504.     ;; Don't modify the undo list at all.
  505.     (buffer-undo-list t)
  506.     (modified (buffer-modified-p))
  507.     (name buffer-file-name)
  508.     insert-end)
  509.     (unwind-protect
  510.     (progn
  511.       (save-excursion
  512.         (goto-char pos)
  513.         ;; defeat file locking... don't try this at home, kids!
  514.         (setq buffer-file-name nil)
  515.         (insert-before-markers (gettext string))
  516.         (setq insert-end (point))
  517.         ;; If the message end is off frame, recenter now.
  518.         (if (> (window-end) insert-end)
  519.         (recenter (/ (window-height) 2)))
  520.         ;; If that pushed message start off the frame,
  521.         ;; scroll to start it at the top of the frame.
  522.         (move-to-window-line 0)
  523.         (if (> (point) pos)
  524.         (progn
  525.           (goto-char pos)
  526.           (recenter 0))))
  527.       (message (or message (gettext "Type %s to continue editing."))
  528.            (single-key-description exit-char))
  529.       (let ((event (save-excursion (next-command-event))))
  530.         (or (eq (event-to-character event) exit-char)
  531.         (setq unread-command-event event))))
  532.       (if insert-end
  533.       (save-excursion
  534.         (delete-region pos insert-end)))
  535.       (setq buffer-file-name name)
  536.       (set-buffer-modified-p modified))))
  537.  
  538. ;;; cmdloop.el ends here
  539.